perm filename TOP3[AM,DBL] blob
sn#166104 filedate 1975-07-03 generic text, type T, neo UTF8
(FILECREATED " 3-JUL-75 01:15:44" <LENAT>TOP3.;10 27774
changes to: APPLYB POR PSUF PXEQ RECTANGLE SEQX
previous date: " 1-JUL-75 23:38:14" <LENAT>TOP3.;9)
(LISPXPRINT (QUOTE TOP3COMS)
T T)
[RPAQQ TOP3COMS
((FNS ACCESS ADD-CANDS ANY1OF APPLYB APPLYB-P ARG-SUBST AVG2 BPFS COM-ANCES COMMENT CPRIN1 CREATEB DE-THRESH
DECRB DEFB DEFP DIE DOTPROD DWIMUSERFN ENSURE ENSURE-TOP FAN FIND-NEW-CANDS FSET-NTH GATH GCB GEN-FNAME
GET-TIME GETARGS GETB GETB-P GETB-P-C GETBQ GETU GEXADD GEXEC GLUE GLUEE GPGM-PRIN GTRANSFER IN-FACTOR
INCRB INIT-PART INSTAN-1D INSTAN-1I INSTAN-1S INSTAN-BASE INSTAN-D INSTAN-I INSTAN-PAT INSTAN-REC
INSTAN-S INT-ENUF IS-CON-L IS-ONE-OF ISA JUST-ONCE KINDS-OF LESS-INT LRU-TAG MAX MAX1 MKSWAPP
MORE-GENERAL MORE-INT MORE-SPECIFIC NCONCB ONE-ISA PGET PICK-CAND POR PRUNABLE PRUNE PSUF PUTB PUTU PXEQ
RAND-CON RAND-MEMB RAND-OBJ RAND-PERMUTE RAND-PRED RAND-SUBSET RAND-THING RAND-USER RE-JUDGE
RECENTLY-TRIED RECTANGLE RIPPLE RIPPLE-SIMULT RIPPLE-UNTIL RIPPLE1 RMUL SAME-TYPE SATISFIES SELF
SELF-COMPILE SEQX SET-DIFF SET-NTH SETB SETBQ SOME-EBP SOMEE START SUB-CANDS SWAPB SWGETB SWITCH SWSETB
TLOOP TYPE UNFORGETTABLE UP-THRESH UPDATE XEQ-CAND XTR-BEING)
(FNS INIT1 INIT-COMP)
CAND-TAIL COMMA CONSTRUCTIVE-OPS CRLF DO-THRESH DWIMUSERFN EX-THRESH F-COUNTER INIT-CANDS INIT-ONCE-LIST
INIT-PAST INIT-DOTHRESH INIT-EXTHRESH INIT-INTHRESH INTHRESH JTRASH RANDSTATE TOP-ACTS TRIVB USERNAMES
VERBOSITY (P (INIT1)
(INIT-COMP))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA TYPE COMMENT ANY1OF)
(NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE JUST-ONCE GETBQ]
(DEFINEQ
(ACCESS
[LAMBDA (A)
A])
(ADD-CANDS
[LAMBDA (C)
(SORT C (QUOTE MORE-INT))
(FRPLACD (SOME C (QUOTE PRUNABLE))
NIL)
(MERGE C CANDS (QUOTE MORE-INT])
(ANY1OF
[NLAMBDA Z
(EVAL (RAND-MEMB Z])
(APPLYB-P
[LAMBDA (B)
(APPLYB B P BA1 BA2 BA3 BA4])
(ARG-SUBST
[LAMBDA (ARG1 NEW1 ARG2 NEW2)
[SET ARG1 (CAR (DSUBST NEW1 ARG1 (DSUBST NEW1 (LIST (QUOTE COPY)
ARG1)
(DSUBST NEW2 ARG2 (DSUBST NEW2 (LIST (QUOTE COPY)
ARG2)
(LIST (COPY (EVAL ARG1]
(SET ARG2 (CAR (DSUBST NEW1 ARG1 (DSUBST NEW1 (LIST (QUOTE COPY)
ARG1)
(DSUBST NEW2 ARG2 (DSUBST NEW2 (LIST (QUOTE COPY)
ARG2)
(LIST (COPY (EVAL ARG2])
(AVG2
[LAMBDA (N1 N2)
(IQUOTIENT (IPLUS N1 N2)
2])
(BPFS
[LAMBDA (B)
(CDDR (CADDR (GETD B])
(COM-ANCES
[LAMBDA (B1 B2 ANLIST)
[MAP2C (DREVERSE (RIPPLE B1 (QUOTE GENL)))
(DREVERSE (RIPPLE B2 (QUOTE GENL)))
(FUNCTION (LAMBDA (AN1 AN2)
(AND (EQ AN1 AN2)
(SETQ ANLIST (CONS AN1 ANLIST]
ANLIST])
(COMMENT
[NLAMBDA X
(CONS (QUOTE COMMENT)
X])
(CPRIN1
[LAMBDA CPARG
(AND (IGREATERP VERBOSITY (ARG CPARG 1))
(FOR CPI FROM 2 TO CPARG DO (PRIN1 (ARG CPARG CPI])
(CREATEB
[LAMBDA (B)
(ATTACH B CONCEPTS)
(PUTHASH B 1 HCON) (* XEQ-CLEAN B)
(PUTD B (COPY TRIVB])
(DE-THRESH
[LAMBDA NIL
(SETQ DO-THRESH (IQUOTIENT (ITIMES DO-THRESH 2)
3))
(CPRIN1 7 " DO-THRESH REDUCED TO " DO-THRESH CRLF)
DO-THRESH])
(DECRB
[LAMBDA (B P X)
(AND X (SETB B P (REMOVE X (GETB B P])
(DEFB
[LAMBDA (B)
[MAPC XS-PARTS (FUNCTION (LAMBDA (XP BP)
(COND
((GETB B XP)
(SETQ BP (GLUEE B XP))
(OR (ASSOC XP (BPFS B))
(ATTACH (LIST XP (CONS BP (GETARGS XP)))
(BPFS B)))
(PUTD BP (LIST (QUOTE LAMBDA)
(GETARGS XP)
(LIST (QUOTE SELF-COMPILE)
BP
(GETB B XP]
(AND (GETB B (QUOTE ALGS))
(NULL (GETB B (QUOTE INV)))
(ATTACH [LIST (QUOTE INV)
(CONS (GLUEE B (QUOTE ALGS))
(GETARGS (QUOTE ALGS]
(BPFS B])
(DEFP
[LAMBDA (F)
(PUTD F (LIST (QUOTE NLAMBDA)
(CONS (QUOTE B)
(AND (FMEMB F XEQ-PARTS)
(GETARGS F)))
(COND
[(FMEMB F SUF-PARTS)
(PUT F (QUOTE INFO)
(QUOTE EVAL))
(CONS (QUOTE PSUF)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
[(FMEMB F OR-PARTS)
(CONS (QUOTE POR)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
[(FMEMB F XEQ-PARTS)
(PUT F (QUOTE INFO)
(QUOTE EVAL))
(CONS (QUOTE PXEQ)
(CONS (KWOTE F)
(CONS (QUOTE B)
(GETARGS F]
(T (LIST (QUOTE PGET)
(KWOTE F)
(QUOTE B])
(DIE
[LAMBDA (MES)
(CPRIN1 -1 CRLF CRLF "*********** AM FATAL COLLAPSE *********** " CRLF MES CRLF CRLF)
(HELP])
(DOTPROD
[LAMBDA (V1 V2)
(OR [AND V1 V2 (PLUS (TIMES (EVAL (CAR V1))
(EVAL (CAR V2)))
(DOTPROD (CDR V1)
(CDR V2]
0])
(DWIMUSERFN
[LAMBDA (X1 X3)
(AND (MATCH (UNPACK FAULTX) WITH (X1←--
'- 'E '- X3←--))
(GETHASH (SETQ X1 (PACK X1))
HCON)
(FMEMB (SETQ X3 (PACK X3))
XEQ-PARTS)
[DEFINE (LIST (LIST FAULTX (LIST (QUOTE LAMBDA)
(GETARGS X3)
(LIST (QUOTE SELF-COMPILE)
X1
(GETB X1 X3]
(CONS FAULTX FAULTARGS])
(ENSURE
[LAMBDA (B P)
(OR (AND (OR (MEMB P FACETS)
(MEMB [PACK (DREVERSE (CDR (DREVERSE (UNPACK P]
FACETS))
(OR (GETHASH B HCON)
(CREATEB B))
(OR (GETB B P)
(INIT-PART B P)))
(CPRIN1 1 "*** WARNING: B,P are not accessable: " B COMMA P CRLF])
(ENSURE-TOP
[LAMBDA NIL
(OR (AND (OR (MEMB CS-P FACETS)
(MEMB [PACK (DREVERSE (CDR (DREVERSE (UNPACK CS-P]
FACETS))
(OR (GETHASH CS-B HCON)
(CREATEB CS-B))
(MEMB CS-OP TOP-ACTS))
(CPRIN1 1 "*** WARNING: CS OP,B,P aren't meaningful (yet):" CRLF CS-OP COMMA CS-B COMMA CS-P])
(FAN
[LAMBDA (MSET MPAR MB1)
(CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
(APPLYB MS1 MPAR MB1])
(FIND-NEW-CANDS
[LAMBDA NIL
(CPRIN1 6 " MUST FIND NEW CANDS " CRLF)
(SETQ INTHRESH (IN-FACTOR DO-THRESH))
(ADD-CANDS (MAPCONC CONCEPTS (QUOTE UNFORGETTABLE])
(FSET-NTH
[LAMBDA (S N X)
(CAR (FRPLACA (FNTH S N)
X])
(GATH
[LAMBDA (B GENB GENP)
(* the old version was: COND ((SETQ GENB (CAR (APPLYB B
(QUOTE UP) (QUOTE FILLIN)))) (COND ((GETHASH (SETQ GENP
(GLUE GENB GATH-PART)) HCON) (ATTACH GENP GPGM))) (COND
((GETHASH (SETQ GENP (GLUE GENB (QUOTE ANYP))) HCON)
(ATTACH GENP GPGM))) (GATH GENB)))
(RIPPLE B GATH-PART (QUOTE GENL])
(GCB
[LAMBDA (N)
[MAPC ONCE-LIST (FUNCTION (LAMBDA (C)
(SETB (CAR C)
(CDR C)
(REMOVE JTRASH (GETB (CAR C)
(CDR C]
(SETQ ONCE-LIST INIT-ONCE-LIST)
(FOR GCX IN (SORT (COPY CONCEPTS)
(QUOTE GET-TIME))
AS GCI FROM 1 TO N DO (SWAPB GCX])
(GEN-FNAME
[LAMBDA (A B)
(PACK (LIST (QUOTE F)
A
(QUOTE -)
B
(QUOTE -)
(SETQ F-COUNTER (ADD1 F-COUNTER])
(GET-TIME
[LAMBDA (B)
(GETU B (QUOTE TIME])
(GETARGS
[LAMBDA (P)
(GETP P (QUOTE ARGS])
(GETB
[LAMBDA (B P)
(SELECTQ P
((EXS EXS-BDY EXS-NOT-BDY EXS-NOT)
(CDDR (GETP B P)))
(GETP B P])
(GETB-P
[LAMBDA (B)
(GETB B P])
(GETB-P-C
[LAMBDA (B)
(COPY (GETB B P])
(GETBQ
[NLAMBDA (B P)
(GETP B P])
(GETU
[LAMBDA (B PROP)
(GET (GETTOPVAL B)
PROP])
(GEXADD
[LAMBDA (X)
(SETQ GEXISTING (UNION GEXISTING X))
X])
(GEXEC
[LAMBDA (GB)
(APPLYB GB GPNAME])
(GLUE
[LAMBDA (B P) (* A more sophisticated scheme can be
implemented: e.g., using HASHing)
(PACK (LIST B (QUOTE -)
P])
(GLUEE
[LAMBDA (B P) (* A more sophisticated scheme can be
implemented: e.g., using HASHing)
(PACK (LIST B (QUOTE -E-)
P])
(GPGM-PRIN
[LAMBDA (GFN GNAM)
(COND
[(CDR GPGM)
(DREMOVE T GPGM)
(CPRIN1 9 " The (G)pgm to " GNAM CRLF CS-B COMMA CS-P " is:" CRLF GPGM)
(SETQ GPNAME (GETHASH GNAM SUF1))
(MAPC GPGM GFN)
(SETQ GPNAME (GETHASH GNAM SUF2))
(MAPC (DREVERSE GPGM)
GFN)
(ADD-CANDS (LIST (LIST 400 (QUOTE RE-JUDGE)
(LIST CS-B CS-P]
((CPRIN1 3 CRLF "***** WARNING: UNABLE TO FIND ANY INFO RELE TO " GNAM " THE " CS-P " PART OF " CS-B CRLF])
(GTRANSFER
[LAMBDA (GEX NEWGP)
(DECRB CS-B CS-P GEX)
(AND (ENSURE CS-B (SETQ GTEMP4 (GLUE CS-P NEWGP)))
(INCRB CS-B GTEMP4 GEX])
(IN-FACTOR
[LAMBDA (N)
(IQUOTIENT N 5])
(INCRB
[LAMBDA (B P X)
(AND X (SETB B P (NCONC1 (OR (GETB B P)
(INIT-PART B P))
X])
(INIT-PART
[LAMBDA (B P)
(OR (GETB B P)
(SETB B P (COPY (GETB (GLUE (QUOTE ANYB)
P)
(QUOTE INIT])
(INSTAN-1D
[LAMBDA (D BASE REC PAT P SFN DTYP DBOD CR CC)
(MATCH D WITH (SFN←&
DTYP←$
DBOD←&))
(SELECTQ (CAR DTYP)
[RECURSIVE (AND [OR (MATCH DBOD WITH ('OR BASE←$
REC←&))
(MATCH DBOD WITH ('COND BASE←$
(REC←&)))
(MATCH DBOD WITH ((QUOTE COND)
BASE←$
((QUOTE T)
REC←$]
(NCONC (INSTAN-BASE BASE)
(INSTAN-REC REC]
[NONRECURSIVE (OR (AND (MATCH DBOD WITH ('MATCH 'BA1 'WITH PAT←&))
(INSTAN-PAT PAT))
(AND (MATCH DBOD WITH (&@[LAMBDA (Z)
(OR (EQ Z (QUOTE EQ))
(EQ Z (QUOTE EQUAL]
CR←&
CC←&))
(CR-INVERT CR CC]
(QUASIRECURSIVE NIL)
(BRANCH NIL)
(IMPLICIT NIL)
(CPRIN1 0 CRLF "******* WARNING: NOT A KNOWN TYPE OF DEFN: " D CRLF " EVAL OF CADR OF THIS IS: " P CRLF
"BACK-TRACING: " CRLF (AM-BT)
CRLF])
(INSTAN-1I
[LAMBDA (I)
(GEXADD (ERRORSET I])
(INSTAN-1S
[LAMBDA (S)
NIL])
(INSTAN-BASE
[LAMBDA (BASE BEX)
(SOMEE BASE (FUNCTION (LAMBDA (BASE1)
(AND (LISTP BASE1)
(NULL (CDR BASE1))
(SETQ BASE1 (CAR BASE1)))
(AND (MATCH BASE1 WITH (&@[LAMBDA (Z)
(OR (EQ Z (QUOTE EQ))
(EQ Z (QUOTE EQUAL]
'BA1 BEX←&))
(ERRORSET BEX])
(INSTAN-D
[LAMBDA (DE)
(MAPCONC (CDR DE)
(QUOTE INSTAN-1D])
(INSTAN-I
[LAMBDA (IN)
(MAPCONC (CDR IN)
(QUOTE INSTAN-1I])
(INSTAN-PAT
[LAMBDA (PAT1)
(SETQ PAT1 (COPY PAT1))
(ATTACH (QUOTE LIST)
PAT1)
(DSUBST (LIST (QUOTE RAND-THING))
(QUOTE &)
PAT1)
(SETQ PAT1 (LSUBST (LIST (LIST (QUOTE RAND-THING))
(LIST (QUOTE RAND-THING)))
(QUOTE --)
PAT1))
(SETQ PAT1 (LSUBST (LIST (LIST (QUOTE RAND-THING))
(LIST (QUOTE RAND-THING)))
(QUOTE $)
PAT1)) (* This should be made recursive, on
CAR, it should call itself if LISTP,
else check unpack for ←)
(GEXADD (ERRORSET PAT1])
(INSTAN-REC
[LAMBDA (REC1 DPROC BOP)
(SETQ REC1 (COPY REC1))
(AND (EQ (CAR REC1)
(QUOTE APPLYB))
(EQ (EVAL (CADDR REC1))
(QUOTE DEFN))
(OR (EQ (EVAL (CADR REC1))
CS-B)
(CPRIN1 2 CRLF "Warning from INSTAN-REC: The concept " (CADR REC1)
", which = "
(EVAL (CADR REC1))
" is NOT equal to CS-B, which = " CS-B CRLF)
T)
(SETQ DPROC (CADDDR REC1))
(GEXADD (OR [AND (EQ (CAR DPROC)
(QUOTE APPLYB))
(EQ (EVAL (CADDR DPROC))
(QUOTE ALGS))
(SETQ BOP (EVAL (CADR DPROC)))
(GETHASH BOP HCON)
(LIST (APPLYB BOP (OR (AND (APPLYB (QUOTE CONSTRUCTIVE)
(QUOTE DEFN)
BOP)
'ALGS)
(QUOTE INV))
(CADDDR DPROC)
(CAR (CDDDDR DPROC))
(CADR (CDDDDR DPROC]
(ERRORSET DPROC])
(INSTAN-S
[LAMBDA (SP)
(MAPCONC (CDR SP)
(QUOTE INSTAN-1S])
(INT-ENUF
[LAMBDA (S)
(AND [SETQ NEW-ILEV (CAR (GETB CS-B (QUOTE WORTH]
(SETQ S (SUBSET (IFEATURES S)
[FUNCTION (LAMBDA (S1)
(AND (SETQ S1 (IFEA S1))
(SETQ NEW-ILEV (IPLUS (IVAL S1)
NEW-ILEV]
(SETQ NEW-ILEV (IQUOTIENT NEW-ILEV (LENGTH S)))
(MAPCAR S (QUOTE IPRED])
(IS-CON-L
[LAMBDA (B)
(AND (GETHASH B HCON)
(LIST B])
(IS-ONE-OF
[LAMBDA (X XSET)
(AND X XSET (OR (FMEMB X XSET)
(SOME (APPLYB X (QUOTE GENL))
(FUNCTION (LAMBDA (X1)
(IS-ONE-OF X1 XSET])
(ISA
[LAMBDA (BNAME BTYPE)
(COND
((EQ BNAME BTYPE))
(BNAME (SOME (APPLYB BNAME (QUOTE GENL))
(FUNCTION (LAMBDA (X1)
(ISA X1 BTYPE])
(JUST-ONCE
[NLAMBDA (X X1)
(COND
((SETQ X1 (EVAL X))
(FRPLACA X (QUOTE COND))
(FRPLACD X NIL)
X1])
(KINDS-OF
[LAMBDA (K)
(OR (GETB K (QUOTE SPEC))
(SUBSET CONCEPTS (FUNCTION (LAMBDA (KC)
(FMEMB K (APPLYB KC (QUOTE GENL])
(LESS-INT
[LAMBDA (A B)
(ILESSP (CAR A)
(CAR B])
(LRU-TAG
[LAMBDA (B)
(PUTU B (QUOTE TIME)
(IQUOTIENT (CLOCK 2)
10000])
(MAX
[LAMBDA (MSET MPAR)
(COND
[MSET (CAR (SORT (MAPCAR MSET MPAR]
(T -1])
(MAX1
[LAMBDA (MSET MPAR MB1)
(CAR (SORT (MAPCAR MSET (FUNCTION (LAMBDA (MS1)
(APPLYB MB1 MPAR MS1])
(MKSWAPP
[LAMBDA (FNAME CDEF)
(NOT (MEMB FNAME (CDAR TOP3COMS])
(MORE-GENERAL
[LAMBDA (B1 B2)
(COND
((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
B2)
((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
B1)
(T NIL])
(MORE-INT
[LAMBDA (A B)
(IGREATERP (CAR A)
(CAR B])
(MORE-SPECIFIC
[LAMBDA (B1 B2)
(COND
((MEMB B1 (RIPPLE B2 (QUOTE GENL)))
B1)
((MEMB B2 (RIPPLE B1 (QUOTE GENL)))
B2)
(T NIL])
(NCONCB
[LAMBDA (B P X)
(AND X (SETB B P (UNION (OR (GETB B P)
(INIT-PART B P))
X])
(ONE-ISA
[LAMBDA (XSET X)
(AND X (CAR (SOME XSET (FUNCTION (LAMBDA (X1)
(ISA X1 X])
(PGET
[LAMBDA (P B)
(MAPCONC (RIPPLE-SIMULT B (GETP P (QUOTE CENT)))
(QUOTE GETB-P-C])
(PICK-CAND
[LAMBDA NIL
(PROG NIL
P1 (COND
((ILESSP (CSINT CANDS)
DO-THRESH)
(DE-THRESH)
(FIND-NEW-CANDS)
(GO P1)))
(SETQ CAND (CSBEST CANDS))
(CPRIN1 5 "NEW CAND = " CAND)
(SETQ CANDS (COND
((CSOTHERS CANDS))
(CAND-TAIL)))
(COND
((RECENTLY-TRIED CAND)
(CPRIN1 3 " REPEATER CAND SKIPPED " CRLF)
(DE-THRESH)
(AND (ZEROP DO-THRESH)
(DIE " DO-THRESH IDENTICALLY ZERO "))
(GO P1))
((AND (SETQ CS-OP (COP CAND))
(SETQ CS-B (CB CAND))
(SETQ CS-P (CP CAND))
(ENSURE-TOP))
(SETQ CS-INT (CINT CAND))
(SETQ CS-ACT (CACT CAND))
(SETQ GEXISTING (GETB CS-B CS-P))
(RETURN CAND)))
(GO P1])
(POR
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (REVERSE (RIPPLE-SIMULT B C1)))
(INIT-PART B P)
(SOME-EBP RS P BA1 BA2 BA3 BA4])
(PRUNABLE
[LAMBDA (C)
(NOT (ILESSP INTHRESH (CINT C])
(PRUNE
[LAMBDA (N)
(FRPLACD (SOME CANDS (QUOTE PRUNABLE))
NIL])
(PSUF
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1 PP)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP P)
(OR (AND BA1 (FMEMB P STRATEGY-PARTS)
(FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (NCONC (SETQ P (GETHASH P SUF1))
(MAPCONC RS (QUOTE APPLYB-P))
(SETQ P (GETHASH P SWSUF))
(MAPCONC (DREVERSE RS)
(QUOTE APPLYB-P])
(PUTB
[LAMBDA (B P Q)
(COND
(Q (PUT B P Q))
(T (REMPROP B P])
(PUTU
[LAMBDA (B PROP PVAL)
(COND
((CAR (ERRORSET B))
(PUTL (EVAL B)
PROP PVAL))
(T (SET B (LIST PROP PVAL])
(PXEQ
[LAMBDA (P B BA1 BA2 BA3 BA4 RS C1 PP)
(SETQ C1 (GETP P (QUOTE CENT)))
(AND (SETQ RS (RIPPLE-SIMULT B C1))
(SETQ PP P)
(OR (AND BA1 (FMEMB P STRATEGY-PARTS)
(FMEMB BA1 FACETS)
(SETQ PP BA1)
[SETQ RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(IS-CON-L (GLUE R BA1]
[NCONC RS (MAPCONC RS (FUNCTION (LAMBDA (R)
(RIPPLE-SIMULT R C1]
(SETQ RS (INTERSECTION RS RS)))
T)
(SETQ GEXISTING (INIT-PART B PP))
(NCONCB B PP (MAPCONC RS (QUOTE APPLYB-P])
(RAND-CON
[LAMBDA NIL
(SETQ RANC (GETHASH RANC CIRC])
(RAND-MEMB
[LAMBDA (S)
[SETQ S (REMOVE NIL (REMOVE (QUOTE ANY1OF)
(REMOVE (QUOTE ANY-OF)
S]
(AND (LISTP S)
(CAR (FNTH S (RAND 1 (LENGTH S])
(RAND-OBJ
[LAMBDA NIL
(CAR (OR (SETQ OBJX (CDR OBJX))
(SETQ OBJX (EXS OBJECT])
(RAND-PERMUTE
[LAMBDA (L L1 M)
(ANY1OF [AND (SETQ L (COPY L))
(CONS (SETQ L1 (RAND-MEMB L))
(RAND-PERMUTE (DREMOVE L1 L]
(PROGN (SETQ M (LIST T))
[MAPC L (FUNCTION (LAMBDA (L1)
(ATTACH L1 (FNTH M (RAND 1 (LENGTH M]
(CDR (DREVERSE M])
(RAND-PRED
[LAMBDA NIL
(ZEROP (RAND 0 1])
(RAND-SUBSET
[LAMBDA (S)
(SUBSET S (QUOTE RAND-PRED])
(RAND-THING
[LAMBDA NIL
(APPLY (GETHASH RANF CIRC])
(RAND-USER
[LAMBDA NIL
(SETQ RANU (GETHASH RANU CIRC])
(RE-JUDGE
[NLAMBDA (RJ I1)
(CPRIN1 8 " SUPPOSED TO RE-JUDGE " RJ CRLF)
(AND [SETQ I1 (ERSETQ (APPLY* (CAR RJ)
(QUOTE C-INT)
(EVAL RJ]
(NUMBERP I1)
(IGREATERP I1 EX-THRESH)
(CREATEB RJ])
(RECENTLY-TRIED
[LAMBDA (C)
(SASSOC (CDR C)
PAST])
(RECTANGLE
[LAMBDA (X1 X2 Y1 Y2)
(COND
((IGREATERP X1 X2)
(SWITCH X1 X2)))
(COND
((IGREATERP Y1 Y2)
(SWITCH Y1 Y2)))
(FOR I1 FROM X1 TO X2 JOIN (FOR I2 FROM Y1 TO Y2 COLLECT (PACK (LIST (QUOTE R)
I1
(QUOTE -)
I2])
(RIPPLE
[LAMBDA (ATYPE XTR-PART)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE)))
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NEW))
(GO L1])
(RIPPLE-SIMULT
[LAMBDA (ATYPE DIRS)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE)))
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC DIRS (FUNCTION (LAMBDA (XTR-PART)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NEW))
(GO L1])
(RIPPLE-UNTIL
[LAMBDA (ATYPE XTR-PART PRED)
(PROG ((NEW (LIST ATYPE))
(OLD (LIST ATYPE))
RVAL)
L1 [SETQ OLD (MAPCONC OLD (FUNCTION (LAMBDA (AL1)
(MAPCONC (GETB AL1 XTR-PART)
(QUOTE XTR-BEING]
(SETQ OLD (INTERSECTION OLD OLD))
(AND [SETQ RVAL (CAR (SOME OLD (LIST (QUOTE LAMBDA)
(LIST (QUOTE B))
PRED]
(RETURN RVAL))
(AND (EQ NEW (SETQ NEW (UNION OLD NEW)))
(RETURN NIL))
(GO L1])
(RIPPLE1
[LAMBDA (B4 P4 DIR RTEMP)
(COND
((LISTP B4)
(SETQ GXTR-PART P4)
[SOME (XTR-BEING B4)
(FUNCTION (LAMBDA (B5)
(SETQ RTEM2 (RIPPLE1 B5 P4 DIR]
RTEM2)
((GETHASH (SETQ RTEMP (GLUE B4 P4))
HCON)
RTEMP)
((GETHASH B4 HCON)
(RIPPLE1 (GETB B4 DIR)
P4 DIR])
(RMUL
[LAMBDA (AMUL IMUL JMUL)
(ITIMES IMUL (IQUOTIENT AMUL JMUL])
(SAME-TYPE
[LAMBDA (B1 B2 BTYP)
(OR (AND (EQ B1 BTYP)
(EQ B2 B1)
B1)
(CADR (MEMB BTYP (COM-ANCES B1 B2])
(SATISFIES
[LAMBDA NIL NIL])
(SELF
[NLAMBDA (X)
(SET X X])
(SELF-COMPILE
[NLAMBDA (BP C AL)
(SETQ LAPFLG NIL)
(SETQ SVFLG NIL)
(SETQ STRF T)
(COMPILE1 BP (LIST (QUOTE LAMBDA)
(SETQ AL (ARGLIST BP))
C))
(EVAL (CONS BP AL])
(SEQX
[LAMBDA (X1)
(OR (EQUAL X1 (CAR X))
(APPLYB (QUOTE STRUCTURE-EQUAL)
(QUOTE ALGS)
(APPEND (CAR X))
(APPEND X1])
(SET-DIFF
[LAMBDA (L M)
(ANY1OF (PROGN (SETQ L (APPEND L))
[MAPC M (FUNCTION (LAMBDA (M1)
(DREMOVE M1 L]
L)
(SUBSET L (FUNCTION (LAMBDA (L1)
(NOT (FMEMB L1 M])
(SET-NTH
[LAMBDA (S N X I)
(COND
((FNTH S N)
(CAR (FRPLACA (FNTH S N)
X)))
((CDR S)
(FOR I FROM (ADD1 (LENGTH S)) TO N DO (NCONC1 S 0))
(CAR (FRPLACA (FNTH S N)
X])
(SETB
[LAMBDA (B P Q BP)
(AND (FMEMB P XEQ-PARTS)
Q
(PUTD (SETQ BP (GLUEE B P))
(LIST (QUOTE LAMBDA)
(GETARGS P)
(LIST (QUOTE SELF-COMPILE)
BP Q)))
(NOT (GETB B P))
(ATTACH (LIST P (CONS BP (GETARGS P)))
(BPFS B)))
(PUT B P Q])
(SETBQ
[NLAMBDA (B P Q)
(SETB B P (EVAL Q])
(SOME-EBP
[LAMBDA (L P BA1 BA2 BA3 BA4)
(AND L (OR (APPLYB (CAR L)
P BA1 BA2 BA3 BA4)
(SOME-EBP (CDR L)
P BA1 BA2 BA3 BA4])
(SOMEE
[LAMBDA (XSET FN)
(PROG (V)
L1 (COND
((SETQ V (APPLY* FN (CAR XSET)))
(RETURN V))
((SETQ XSET (CDR XSET))
(GO L1))
((RETURN NIL])
(START
[LAMBDA NIL
(SETQ PKNT 0)
(SETQ DO-THRESH INIT-DOTHRESH)
(SETQ EX-THRESH INIT-EXTHRESH)
(SETQ INTHRESH INIT-INTHRESH)
(SETQ CANDS (COPY INIT-CANDS))
(SETQ PAST (COPY INIT-PAST))
(TERPRI)
(PRIN1 "ENTERING MAIN LOOP NOW.")
(TERPRI)
(TERPRI)
(TLOOP)
(TERPRI)
(PRIN1 "RE-")
(START])
(SUB-CANDS
[LAMBDA (SL)
[MAPC SL (FUNCTION (LAMBDA (S)
(SOME CANDS (FUNCTION (LAMBDA (C)
(AND (EQUAL (CACT C)
(CACT S))
(RPLACA C (IQUOTIENT (CINT C)
2] (* This is rather an inefficient way to
do this.)
(SORT CANDS (QUOTE MORE-INT])
(SWAPB
[LAMBDA (B PFILE)
(COND
((GETU B (QUOTE FOUT)))
((PUTU B (QUOTE FOUT)
(LIST (SETQ PFILE (GETPROPERFILE))
(GETPROPERFILEPOS)))
(PRIN2 (GETPROPLIST B)
PFILE)))
(COND
((FMEMB B NOSWAP-CONCEPTS))
((SETPROPLIST B 0])
(SWGETB
[LAMBDA (B P F)
(LRU-TAG B)
(COND
((GET B P))
((ZEROP (GETPROPLIST B))
(SETQ F (GETU B (QUOTE FOUT)))
[COND
((ATOM F)
(LOADVARS (LIST (LIST (QUOTE (QUOTE PUTPROPS))
(KWOTE B)
(QUOTE $)))
F T))
(T (SETFILEPTR (CAR F)
(CADR F]
(SETQ B (READ (CAR F)))
(GET B P])
(SWITCH
[NLAMBDA (C1 C2 CTEMP)
(SETQ CTEMP (EVAL C1))
(SET C1 (EVAL C2))
(SET C2 CTEMP])
(SWSETB
[LAMBDA (B P Q BP)
(AND (FMEMB P XEQ-PARTS)
(PUTD (SETQ BP (GLUEE B P))
(LIST (QUOTE LAMBDA)
(GETARGS P)
(LIST (QUOTE SELF-COMPILE)
BP Q)))
(NOT (GETB B P))
(ATTACH (NCONC (LIST P (LIST BP))
(GETARGS P))
(BPFS B)))
(AND (GETU B (QUOTE FOUT))
(PUTU B (QUOTE FOUT)
NIL))
(LRU-TAG B)
(PUT B P Q])
(TLOOP
[LAMBDA NIL
(TERPRI)
(PRIN1 "VERBOSITY LEVEL (0-10) ... ")
(SETQ VERBOSITY (RATOM))
(PROG NIL
L1 (PICK-CAND)
(XEQ-CAND)
(UPDATE)
(GO L1])
(TYPE
[NLAMBDA X
(EVAL (CAR (FLAST X])
(UNFORGETTABLE
[LAMBDA (B P I F ARG1)
(* Each C-SUGGESTS part is ordered: first, when to definitely reject recognition;
next, when to definitely accept it. If it accepts, the being decides on part P, interest level I,
function to do to it F, and then returns (I F (B P args)))
(APPLYB B (QUOTE SUGG)
INTHRESH])
(UP-THRESH
[LAMBDA NIL
(SETQ DO-THRESH (IQUOTIENT (IPLUS DO-THRESH (CINT CAND))
2])
(UPDATE
[LAMBDA NIL
(UP-THRESH)
(SETQ INTHRESH (IN-FACTOR DO-THRESH))
(PRUNE INTHRESH)
(SETQ PAST (CONS (CONS (CDR CAND)
CVAL)
(DREMOVE (CAR (FLAST PAST))
PAST])
(XEQ-CAND
[LAMBDA NIL
(SETQ CVAL (EVAL CS-ACT])
(XTR-BEING
[LAMBDA (B) (* This actually will depend on the
format of the part being worked on.
This part is to be assigned to the
variable XTR-PART)
(COND
((ATOM B)
(AND (GETHASH B HCON)
(LIST B)))
((LISTP B)
(COND
((EQUAL (CAR B)
(QUOTE OR-RUN:))
(EVAL (CADR B)))
(T (MAPCONC B (QUOTE XTR-BEING])
)
(DEFINEQ
(INIT1
[LAMBDA NIL
(CLDISABLE (QUOTE -))
(WIDEPAPER T)
(RAISE)
[INTERRUPTCHAR 24 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** BACKTRACING:")
(TERPRI)
(AM-BT)
(TERPRI)
(PRIN1 "*** END OF BACKTRACE")
(TERPRI]
[INTERRUPTCHAR 25 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** NUMBER OF CANDS IS ")
(PRINT (LENGTH CANDS]
[INTERRUPTCHAR 26 (QUOTE (PROGN (TERPRI)
(PRIN1 " *** INTEREST ")
(PRIN1 DO-THRESH)
(PRIN1 ", ")
(PRIN1 INTHRESH)
(PRIN1 ", NCANDS=")
(PRIN1 (LENGTH CANDS))
(PRIN1 ", CAND=")
(PRINT CAND]
(TERPRI)
(PRIN1 "YOU PROBABLY WANT TO LOAD IN THE FILE CON3 NOW")
(RANDSET RANDSTATE)
(TERPRI])
(INIT-COMP
[LAMBDA NIL
[COND
((NOT (GETD (QUOTE GETTOPVAL)))
(MOVD (QUOTE CAR)
(QUOTE GETTOPVAL))
(MOVD (QUOTE CDR)
(QUOTE GETPROPLIST))
[PUTD (QUOTE SETTOPVAL)
(QUOTE (LAMBDA (X Y)
(CAR (FRPLACA X Y]
[PUTD (QUOTE SETPROPLIST)
(QUOTE (LAMBDA (X Y)
(CDR (FRPLACD X Y]
[PUTD (QUOTE /SETTOPVAL)
(QUOTE (LAMBDA (X Y)
(CAR (/RPLACA X Y]
[PUTD (QUOTE /SETPROPLIST)
(QUOTE (LAMBDA (X Y)
(CDR (/RPLACD X Y]
(NCONC LISPXFNS (QUOTE ((SETTOPVAL . /SETTOPVAL)
(SETPROPLIST . /SETPROPLIST]
[COND
((NOT (GETD (QUOTE GETFILEPTR)))
(MOVD (QUOTE SFPTR)
(QUOTE GETFILEPTR))
(PUTD (QUOTE SETFILEPTR)
(QUOTE (LAMBDA (FILE PTR)
(PROG1 PTR (SFPTR FILE PTR]
(DEFLIST [QUOTE ((GETTOPVAL ((X)
(CAR X)))
(GETPROPLIST ((X)
(CDR X]
(QUOTE MACRO])
)
[RPAQQ CAND-TAIL ((0 PRINT (QUOTE TAIL-MARK]
(RPAQQ COMMA ", ")
(RPAQQ CONSTRUCTIVE-OPS (STRUCTURE-INSERT UNION NCONC ATTACH MAPSTRUC CONS UNITE APPEND LIST))
(RPAQQ CRLF "
")
(RPAQQ DO-THRESH 168)
(RPAQQ DWIMUSERFN T)
(RPAQQ EX-THRESH 500)
(RPAQQ F-COUNTER 0)
[RPAQQ INIT-CANDS ((0 PRIN1 (QUOTE TAIL-MARK]
(RPAQQ INIT-ONCE-LIST (ANYB ANYP))
(RPAQQ INIT-PAST ((A B)
(C D)
(E F)
(G H)
(I J)
(K L)))
(RPAQQ INIT-DOTHRESH 1535)
(RPAQQ INIT-EXTHRESH 500)
(RPAQQ INIT-INTHRESH 1000)
(RPAQQ INTHRESH 33)
(RPAQQ JTRASH (JUST-ONCE (COND)))
(RPAQQ RANDSTATE (-6630037411 . -20593999596))
(RPAQQ TOP-ACTS (ACCESS ADD-CANDS CHECK EVAL EXPR-IN FILLIN GOAL INIT-PART INSTANTIATE PRIN1 PRINT RE-JUDGE RESTRUC
SUB-CANDS TRANSLATE))
(RPAQQ TRIVB [LAMBDA (BP BA1 BA2 BA3 BA4)
(SELECTQ BP NIL])
(RPAQQ USERNAMES (AVRA BRUCE CORDELL DOUG ED))
(RPAQQ VERBOSITY 10)
(INIT1)
(INIT-COMP)
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA TYPE COMMENT ANY1OF)
(ADDTOVAR NLAML SWITCH SETBQ SELF-COMPILE SELF RE-JUDGE JUST-ONCE GETBQ)
]
(DECLARE: DONTCOPY
(FILEMAP (NIL (1780 24883 (ACCESS 1792 . 1823) (ADD-CANDS 1827 . 1973) (ANY1OF 1977 . 2024) (APPLYB-P 2028 . 2087)
(ARG-SUBST 2091 . 2543) (AVG2 2547 . 2614) (BPFS 2618 . 2666) (COM-ANCES 2670 . 2907) (COMMENT 2911 . 2968) (CPRIN1
2972 . 3097) (CREATEB 3101 . 3273) (DE-THRESH 3277 . 3443) (DECRB 3447 . 3516) (DEFB 3520 . 4046) (DEFP 4050 . 4718)
(DIE 4722 . 4847) (DOTPROD 4851 . 4994) (DWIMUSERFN 4998 . 5354) (ENSURE 5358 . 5645) (ENSURE-TOP 5649 . 5965) (FAN
5969 . 6083) (FIND-NEW-CANDS 6087 . 6262) (FSET-NTH 6266 . 6333) (GATH 6337 . 6699) (GCB 6703 . 6999) (GEN-FNAME 7003
. 7130) (GET-TIME 7134 . 7185) (GETARGS 7189 . 7239) (GETB 7243 . 7370) (GETB-P 7374 . 7413) (GETB-P-C 7417 . 7464)
(GETBQ 7468 . 7509) (GETU 7513 . 7572) (GEXADD 7576 . 7649) (GEXEC 7653 . 7700) (GLUE 7704 . 7910) (GLUEE 7914 . 8123)
(GPGM-PRIN 8127 . 8599) (GTRANSFER 8603 . 8747) (IN-FACTOR 8751 . 8798) (INCRB 8802 . 8908) (INIT-PART 8912 . 9038)
(INSTAN-1D 9042 . 9986) (INSTAN-1I 9990 . 10042) (INSTAN-1S 10046 . 10082) (INSTAN-BASE 10086 . 10401) (INSTAN-D 10405
. 10479) (INSTAN-I 10483 . 10557) (INSTAN-PAT 10561 . 11186) (INSTAN-REC 11190 . 12035) (INSTAN-S 12039 . 12113) (
INT-ENUF 12117 . 12431) (IS-CON-L 12435 . 12499) (IS-ONE-OF 12503 . 12666) (ISA 12670 . 12839) (JUST-ONCE 12843 .
12962) (KINDS-OF 12966 . 13104) (LESS-INT 13108 . 13170) (LRU-TAG 13174 . 13264) (MAX 13268 . 13364) (MAX1 13368 .
13483) (MKSWAPP 13487 . 13558) (MORE-GENERAL 13562 . 13719) (MORE-INT 13723 . 13791) (MORE-SPECIFIC 13795 . 13953)
(NCONCB 13957 . 14061) (ONE-ISA 14065 . 14162) (PGET 14166 . 14267) (PICK-CAND 14271 . 15067) (POR 15071 . 15257)
(PRUNABLE 15261 . 15322) (PRUNE 15326 . 15404) (PSUF 15408 . 16055) (PUTB 16059 . 16142) (PUTU 16146 . 16286) (PXEQ
16290 . 16798) (RAND-CON 16802 . 16863) (RAND-MEMB 16867 . 17033) (RAND-OBJ 17037 . 17130) (RAND-PERMUTE 17134 . 17416)
(RAND-PRED 17420 . 17469) (RAND-SUBSET 17473 . 17534) (RAND-THING 17538 . 17597) (RAND-USER 17601 . 17663) (RE-JUDGE
17667 . 17888) (RECENTLY-TRIED 17892 . 17956) (RECTANGLE 17960 . 18242) (RIPPLE 18246 . 18604) (RIPPLE-SIMULT 18608
. 19020) (RIPPLE-UNTIL 19024 . 19539) (RIPPLE1 19543 . 19857) (RMUL 19861 . 19935) (SAME-TYPE 19939 . 20067) (SATISFIES
20071 . 20102) (SELF 20106 . 20143) (SELF-COMPILE 20147 . 20357) (SEQX 20361 . 20496) (SET-DIFF 20500 . 20698) (SET-NTH
20702 . 20912) (SETB 20916 . 21204) (SETBQ 21208 . 21259) (SOME-EBP 21263 . 21418) (SOMEE 21422 . 21608) (START 21612
. 21970) (SUB-CANDS 21974 . 22297) (SWAPB 22301 . 22584) (SWGETB 22588 . 22932) (SWITCH 22936 . 23042) (SWSETB 23046
. 23431) (TLOOP 23435 . 23644) (TYPE 23648 . 23694) (UNFORGETTABLE 23698 . 24048) (UP-THRESH 24052 . 24154) (UPDATE
24158 . 24367) (XEQ-CAND 24371 . 24426) (XTR-BEING 24430 . 24880)) (24885 26596 (INIT1 24897 . 25673) (INIT-COMP 25677
. 26593)))))
STOP